perm filename WLDMOD.SAI[OLD,HE] blob
sn#500992 filedate 1980-04-09 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
C00003 00003 ! vnode_cmp, vnode_merge, merge_calcs, merge_remcalcs, new_thread
C00010 00004 ! pop_thread, push_thread, merge_threads, and_threads
C00017 00005 ! new_exprn, stmake, stmchk
C00019 00006 ! device, controllable, find_deproach, depr
C00025 00007 ! dexprset, domove
C00048 00008 ! dooperate, docenter, dostop
C00055 00009 ! do_affix, do_unfix
C00060 00010 ! blockdo & sttblk
C00065 00011 ! Cobdo
C00066 00012 ! statement interpreter: stinterp
C00075 ENDMK
C⊗;
IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
ENTRY;
BEGIN "WLDMOD"
IFCR ¬DECLARATION(CREFFING) THENC DEFINE CREFFING = FALSE;ENDC
IFCR ¬ CREFFING THENC
REQUIRE "ALREQ.HDR[AL,HE]" SOURCE_FILE;
ENDC
REDEFINE $$PRGID "[]" = ["WLDMOD"];
ENDC
EXTERNAL SIMPLE PROCEDURE ARYEL(INTEGER A);
REQUIRE 300 SYSTEM_PDL;
RPTR(BLOCK) CURBLK; ! id of current block in stinterp;
! vnode_cmp, vnode_merge, merge_calcs, merge_remcalcs, new_thread;
BOOLEAN PROCEDURE VNODE_CMP (RPTR(VNODE) V1,V2);
BEGIN
IF V1=RNULL ∨ V2=RNULL ∨ VNODE:VAL[V1]=RNULL ∨ VNODE:VAL[V2]=RNULL
THEN RETURN(FALSE);
CASE VARIABLE:DATATYPE[VNODE:VAR[V1]] OF
BEGIN
[SVAL_DTYPE] RETURN(SVAL:VAL[VNODE:VAL[V1]]=SVAL:VAL[VNODE:VAL[V2]]);
[V3ECT_DTYPE] RETURN(V3CMP(VNODE:VAL[V1],VNODE:VAL[V2])=0);
[ROTN_DTYPE] RETURN(ROTCMP(VNODE:VAL[V1],VNODE:VAL[V2])=0);
[TRANS_DTYPE] RETURN(TRANSCMP(VNODE:VAL[V1],VNODE:VAL[V2])=0);
[FRAME_DTYPE] RETURN(TRANSCMP(FRAME:VAL[VNODE:VAL[V1]],FRAME:VAL[VNODE:VAL[V2]])=0);
ELSE RETURN(FALSE)
END
END;
PROCEDURE VNODE_MERGE(RPTR(VNODE) V1,V2,VT; BOOLEAN HOW);
BEGIN ! If HOW = true then OR threads else AND them;
RPTR(VNODE) V;
V1 ← VNODE:NEXT[V1];
V2 ← VNODE:NEXT[V2];
WHILE V1 ≠ RNULL ∧ V2 ≠ RNULL DO ! Merge the two value threads;
BEGIN
IF VNODE:VAR[V1] = VNODE:VAR[V2] THEN ! See if both threads have equal values;
BEGIN
VT ← VNODE:NEXT[VT] ← V1;
IF ¬VNODE_CMP(V1,V2) THEN VNODE:VAL[V1] ← RNULL; ! Values cancel;
V1 ← VNODE:NEXT[V1];
V2 ← VNODE:NEXT[V2]
END
ELSE
BEGIN
IF VNODE:VAR[V1] < VNODE:VAR[V2]
THEN V1 ← VNODE:NEXT[(V←V1)] ELSE V2 ← VNODE:NEXT[(V←V2)];
IF ¬VNODE_CMP(V,VARIABLE:PLNVAL[VNODE:VAR[V]]) THEN
BEGIN
VT ← VNODE:NEXT[VT] ← V;
IF ¬HOW THEN VNODE:VAL[V] ← RNULL ! Value now undefined;
END
END
END;
V ← VNODE:NEXT[VT] ← IF V1 ≠ RNULL THEN V1 ELSE V2;
WHILE V ≠ RNULL DO
IF VNODE_CMP(V,VARIABLE:PLNVAL[VNODE:VAR[V]]) THEN
VNODE:NEXT[VT] ← V ← VNODE:NEXT[V] ! Same as before, so ignore it;
ELSE
BEGIN
IF ¬HOW THEN VNODE:VAL[V] ← RNULL; ! Value now undefined;
V ← VNODE:NEXT[(VT←V)]
END
END;
RPTR(CALC) PROCEDURE MERGE_CALCS (RTHREAD T1,T2,T; BOOLEAN HOW);
BEGIN ! If HOW = true then OR threads else AND them;
RPTR(CALC) C1,C2,CT;
C1 ← THREAD:CALCS[T1];
C2 ← THREAD:CALCS[T2];
THREAD:CALCS[T] ← CT ← NEW_RECORD(CALC); ! Dummy header calc - killed later;
WHILE C1 ≠ RNULL ∧ C2 ≠ RNULL DO ! Merge the two affixment threads;
BEGIN
IF CALC:US[C1] = CALC:US[C2] THEN ! See if both calcs affix same frames;
IF CALC:OTHER[C1] = CALC:OTHER[C2] THEN
BEGIN
IF CALC:BVAR[C1]=CALC:BVAR[C2] ∧ CALC:TYPE[C1]=CALC:TYPE[C2]
THEN CT ← CALC:NEXT[CT] ← C1;
C1 ← CALC:NEXT[C1];
C2 ← CALC:NEXT[C2]
END
ELSE IF CALC:OTHER[C1] < CALC:OTHER[C2]
THEN BEGIN IF HOW THEN CT←CALC:NEXT[CT]←C1; C1←CALC:NEXT[C1] END
ELSE BEGIN IF HOW THEN CT←CALC:NEXT[CT]←C2; C2←CALC:NEXT[C2] END
ELSE IF CALC:US[C1] < CALC:US[C2]
THEN BEGIN IF HOW THEN CT←CALC:NEXT[CT]←C1; C1←CALC:NEXT[C1] END
ELSE BEGIN IF HOW THEN CT←CALC:NEXT[CT]←C2; C2←CALC:NEXT[C2] END
END;
IF HOW THEN CALC:NEXT[CT] ← IF C1 ≠ RNULL THEN C1 ELSE C2;
THREAD:CALCS[T] ← CALC:NEXT[THREAD:CALCS[T]]; ! Kill dummy header calc;
END;
RPTR(CALC) PROCEDURE MERGE_REMCALCS (RTHREAD T1,T2,T; BOOLEAN HOW);
BEGIN ! If HOW = true then OR threads else AND them;
RPTR(CALC) C1,C2,CT;
C1 ← THREAD:REMCALCS[T1];
C2 ← THREAD:REMCALCS[T2];
THREAD:REMCALCS[T] ← CT ← NEW_RECORD(CALC); ! Dummy header calc - killed later;
WHILE C1 ≠ RNULL ∧ C2 ≠ RNULL DO ! Merge the two unfixment threads;
BEGIN
IF CALC:US[C1] = CALC:US[C2] THEN ! See if both calcs affix same frames;
IF CALC:OTHER[C1] = CALC:OTHER[C2] THEN
BEGIN
CT ← CALC:REMCALC[CT] ← C1;
C1 ← CALC:REMCALC[C1];
C2 ← CALC:REMCALC[C2]
END
ELSE IF CALC:OTHER[C1] < CALC:OTHER[C2]
THEN BEGIN IF HOW THEN CT←CALC:REMCALC[CT]←C1; C1←CALC:REMCALC[C1] END
ELSE BEGIN IF HOW THEN CT←CALC:REMCALC[CT]←C2; C2←CALC:REMCALC[C2] END
ELSE IF CALC:US[C1] < CALC:US[C2]
THEN BEGIN IF HOW THEN CT←CALC:REMCALC[CT]←C1; C1←CALC:REMCALC[C1] END
ELSE BEGIN IF HOW THEN CT←CALC:REMCALC[CT]←C2; C2←CALC:REMCALC[C2] END
END;
IF HOW THEN CALC:REMCALC[CT] ← IF C1 ≠ RNULL THEN C1 ELSE C2;
THREAD:REMCALCS[T] ← CALC:REMCALC[THREAD:REMCALCS[T]]; ! Kill dummy header;
END;
RTHREAD PROCEDURE NEW_THREAD;
BEGIN
RTHREAD T;
T ← NEW_RECORD(THREAD);
THREAD:VALS[T] ← NEW_RECORD(VNODE);
THREAD:DEPRS[T] ← NEW_RECORD(VNODE);
RETURN(T)
END;
! pop_thread, push_thread, merge_threads, and_threads;
RTHREAD PROCEDURE POP_THREAD (RTHREAD T);
BEGIN
RPTR(VNODE) V;
RPTR(CALC) C1,C2;
V ← VNODE:NEXT[THREAD:VALS[T]];
WHILE V ≠ RNULL DO ! First try to validate any invalid variables;
BEGIN
IF VNODE:INVMARK[V] THEN GETVALUE(VNODE:VAR[V],T,TRUE);
V ← VNODE:NEXT[V]
END;
V ← VNODE:NEXT[THREAD:VALS[T]];
WHILE V ≠ RNULL DO ! Undo any values assigned in this thread;
BEGIN
VARIABLE:PLNVAL[VNODE:VAR[V]] ← VNODE:OLDVAL[V]; ! Restore old value;
V ← VNODE:NEXT[V]
END;
V ← VNODE:NEXT[THREAD:DEPRS[T]];
WHILE V ≠ RNULL DO ! Undo any deproaches that were set;
BEGIN
VARIABLE:DEPR[VNODE:VAR[V]] ← VNODE:OLDVAL[V]; ! Restore old value;
V ← VNODE:NEXT[V]
END;
C1 ← THREAD:CALCS[T];
WHILE C1 ≠ RNULL DO ! Undo any affixing that was done;
BEGIN
C2 ← VARIABLE:CALCS[CALC:US[C1]]; ! Remove calc from list;
IF C1 = C2 THEN VARIABLE:CALCS[CALC:US[C1]] ← CALC:NXTCALC[C2]
ELSE BEGIN
WHILE C2 ≠ RNULL ∧ CALC:NXTCALC[C2] ≠ C1 DO C2 ← CALC:NXTCALC[C2];
IF C2 ≠ RNULL THEN CALC:NXTCALC[C2] ← CALC:NXTCALC[C1]
END;
C1 ← CALC:NEXT[C1]
END;
C1 ← THREAD:REMCALCS[T];
WHILE C1 ≠ RNULL DO ! Undo any unfixing that was done;
BEGIN
CALC:NXTCALC[C1] ← VARIABLE:CALCS[CALC:US[C1]];
VARIABLE:CALCS[CALC:US[C1]] ← C1; ! Put us back on list of calcs;
C1 ← CALC:REMCALC[C1]
END;
END;
PROCEDURE PUSH_THREAD (RTHREAD T,WLD); ! Copy the effects of T into WLD;
BEGIN
RPTR(VNODE) V;
RPTR(CALC) C,C1,C2;
V ← VNODE:NEXT[THREAD:VALS[T]];
WHILE V ≠ RNULL DO ! Assign any values made in this thread;
BEGIN
VCHANGE(VNODE:VAR[V],VNODE:VAL[V],WLD);
V ← VNODE:NEXT[V]
END;
V ← VNODE:NEXT[THREAD:DEPRS[T]];
WHILE V ≠ RNULL DO ! Add any deproaches set in new thread;
BEGIN
DCHANGE(VNODE:VAR[V],VNODE:VAL[V],WLD);
V ← VNODE:NEXT[V]
END;
C2 ← C1 ← THREAD:CALCS[T];
WHILE C1 ≠ RNULL DO ! Do any affixing that was done;
BEGIN
CALC:THREAD[C1] ← WLD;
CALC:NXTCALC[C1] ← VARIABLE:CALCS[CALC:US[C1]]; ! Add calc to list;
VARIABLE:CALCS[CALC:US[C1]] ← C1;
C1 ← CALC:NEXT[(C2←C1)]
END;
IF C2 ≠ RNULL THEN
BEGIN
CALC:NEXT[C2] ← THREAD:CALCS[WLD]; ! Append to WLD's affixment list;
THREAD:CALCS[WLD] ← THREAD:CALCS[T]
END;
C1 ← THREAD:REMCALCS[T];
C2 ← RNULL;
WHILE C1 ≠ RNULL DO ! Do any unfixing that was done;
BEGIN
C ← VARIABLE:CALCS[CALC:US[C1]]; ! Remove calc from list;
IF C1 = C THEN VARIABLE:CALCS[CALC:US[C1]] ← CALC:NXTCALC[C]
ELSE BEGIN
WHILE C ≠ RNULL ∧ CALC:NXTCALC[C] ≠ C1 DO C ← CALC:NXTCALC[C];
IF C ≠ RNULL THEN CALC:NXTCALC[C] ← CALC:NXTCALC[C1]
END;
! Make sure we don't add calcs created by WLD to WLD's unfix list;
IF CALC:THREAD[C1] = WLD THEN
IF C2 = RNULL THEN C1 ← CALC:REMCALC[C1]
ELSE C1 ← CALC:REMCALC[C2] ← CALC:REMCALC[C1]
ELSE C1 ← CALC:REMCALC[(C2←C1)]
END;
IF C2 ≠ RNULL THEN
BEGIN
CALC:REMCALC[C2] ← THREAD:REMCALCS[WLD]; ! Append to WLD's unfix list;
THREAD:REMCALCS[WLD] ← THREAD:REMCALCS[T]
END;
END;
RTHREAD PROCEDURE MERGE_THREADS (RTHREAD T1,T2);
BEGIN
RTHREAD T;
RPTR(VNODE) V1,V2,VT;
T ← NEW_THREAD;
V1 ← THREAD:VALS[T1];
V2 ← THREAD:VALS[T2];
VT ← THREAD:VALS[T];
VNODE_MERGE(V1,V2,VT,TRUE);
V1 ← THREAD:DEPRS[T1];
V2 ← THREAD:DEPRS[T2];
VT ← THREAD:DEPRS[T];
VNODE_MERGE(V1,V2,VT,TRUE);
MERGE_CALCS(T1,T2,T,TRUE);
MERGE_REMCALCS(T1,T2,T,TRUE);
RETURN (T);
END;
RTHREAD PROCEDURE AND_THREADS (RTHREAD T1,T2);
BEGIN
RTHREAD T;
RPTR(VNODE) V1,V2,VT;
T ← NEW_THREAD;
V1 ← THREAD:VALS[T1];
V2 ← THREAD:VALS[T2];
VT ← THREAD:VALS[T];
VNODE_MERGE(V1,V2,VT,FALSE);
V1 ← THREAD:DEPRS[T1];
V2 ← THREAD:DEPRS[T2];
VT ← THREAD:DEPRS[T];
VNODE_MERGE(V1,V2,VT,FALSE);
MERGE_CALCS(T1,T2,T,FALSE);
MERGE_REMCALCS(T1,T2,T,FALSE);
RETURN (T);
END;
! new_exprn, stmake, stmchk;
INTERNAL RPTR(EXPRN) PROCEDURE NEW_EXPRN(INTEGER DT,OP;RCELL ARGS);
BEGIN
RPTR(EXPRN) E;
E←NEW_RECORD(EXPRN);
EXPRN:DATATYPE[E]←DT;
EXPRN:OP[E]←OP;
EXPRN:ARGS[E]←ARGS;
RETURN(E);
END;
INTERNAL RPTR(STMNT) PROCEDURE STMAKE(RSSS SEM(NULL_RECORD));
BEGIN
RPTR(STMNT) S;
S←NEW_RECORD(STMNT);
STMNT:SEMANTICS[S]←SEM;
RETURN(S);
END;
! be sure S is a statement;
RPTR(STMNT) PROCEDURE STMCHK(RANY S);
IF S = RNULL THEN RETURN(S)
ELSE IF RECTYPE(S)=LOC(EXPRN) ∧ EXPRN:OP[S]=CALL_OP THEN RETURN(STMAKE(S))
ELSE RETURN(CHKREC(S,LOC(STMNT)));
! device, controllable, find_deproach, depr;
INTEGER TEMP; INITIALIZE(TEMP←0);
BOOLEAN PROCEDURE DEVICE(RVAR A);
IF A = BHAND ∨ A = YHAND
∨ A = DRIVER ∨ A = VISE ! add other devices here;
THEN RETURN(TRUE) ELSE RETURN(FALSE);
BOOLEAN RECPROC CONTROLLABLE(RVAR A; REFERENCE RVAR CF; REFERENCE REXPR BYEXP;
REFERENCE RCELL SEEN);
BEGIN
INTEGER RT;
RVAR N;
RPTR(CALC) C;
RPTR(VARIABLE,EXPRN) BYE;
RPTR(EXPRN) E;
IF A=BARM ∨ A=YARM THEN
BEGIN
BYEXP ← NULL_RECORD;
CF ← A;
RETURN(TRUE);
END;
CONSON(A,SEEN); ! Add A to the list of variables we've checked;
C ← VARIABLE:CALCS[A];
WHILE C ≠ RNULL DO
BEGIN
N ← CALC:OTHER[C];
IF ¬MEMQ(N,SEEN) ∧ CONTROLLABLE(N,CF,E,SEEN) THEN
BEGIN
BYE ← CALC:BVAR[C];
IF E=NULL_RECORD THEN BYEXP←BYE
ELSE BYEXP←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,LIST2(E,BYE));
IF VARIABLE:NAME[BYE]=NULL THEN ! Check if trans is named;
BEGIN ! No, Must make it an explicitly named trans;
CONSON(BYE,BLOCK:VARS[VARIABLE:BLK[BYE]]);
VARIABLE:NAME[BYE] ← ".T"&CVS(TEMP←TEMP+1);
END;
RETURN(TRUE);
END;
C ← CALC:NXTCALC[C];
END;
RETURN(FALSE);
END;
RECURSIVE BOOLEAN PROCEDURE FIND_DEPROACH(RVAR WHAT;
REFERENCE REXPR HOW; RCELL SEEN);
BEGIN
INTEGER RT;
RVAR N;
RPTR(CALC) C;
RPTR(VARIABLE,EXPRN) BYE;
REXPR E;
IF VARIABLE:DEPR[WHAT] ≠ RNULL THEN
BEGIN ! make sure we return a trans or vector;
HOW ← VNODE:VAL[VARIABLE:DEPR[WHAT]];
IF HOW=NILDEPROACH THEN RETURN(TRUE);
IF (RT←RECTYPE(HOW))=LOC(VARIABLE) THEN RT ← DTYPE(VARIABLE:DATATYPE[HOW])
ELSE IF RT=LOC(EXPRN) THEN RT←DTYPE(EXPRN:DATATYPE[HOW]);
IF RT=LOC(SVAL) THEN HOW←NEW_EXPRN(V3ECT_DTYPE,SVMUL_OP,LIST2(HOW,ZHAT));
RETURN(TRUE);
END;
CONSON(WHAT,SEEN); ! Add WHAT to the list of variables checked;
C ← VARIABLE:CALCS[WHAT];
WHILE C ≠ RNULL DO
BEGIN
N ← CALC:OTHER[C];
IF ¬MEMQ(N,SEEN) ∧ FIND_DEPROACH(N,E,SEEN) THEN
BEGIN
BYE ← CALC:BVAR[C];
IF E = NILDEPROACH THEN HOW ← NILDEPROACH
ELSE
BEGIN
RT ← RECTYPE(E);
IF RT = LOC(VARIABLE) THEN RT ← DTYPE(VARIABLE:DATATYPE[E])
ELSE IF RT = LOC(EXPRN) THEN RT ← EXPRN:DATATYPE[E];
IF RT = LOC(V3ECT) THEN HOW←NEW_EXPRN(V3ECT_DTYPE,RVMUL_OP,
LIST2(NEW_EXPRN(ROTN_DTYPE,ORIENT_OP,CONS(BYE,RNULL)),E))
ELSE HOW←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,LIST2(
NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NEW_EXPRN(
ROTN_DTYPE,ORIENT_OP,CONS(BYE,RNULL)),NILVECT)),E));
IF VARIABLE:NAME[BYE]=NULL THEN ! Check if trans is named;
BEGIN ! No, Must make it an explicitly named trans;
CONSON(BYE,BLOCK:VARS[VARIABLE:BLK[BYE]]);
VARIABLE:NAME[BYE] ← ".T"&CVS(TEMP←TEMP+1)
END
END;
RETURN(TRUE)
END;
C ←CALC:NXTCALC[C]
END;
RETURN(FALSE)
END;
INTERNAL REXPR PROCEDURE DEPR(RVAR WHAT);
BEGIN
REXPR HOW;
RCELL SEEN;
SEEN ← RNULL;
IF FIND_DEPROACH(WHAT,HOW,SEEN) THEN
BEGIN
INTEGER RT;
IF HOW = NILDEPROACH THEN RETURN(HOW);
RT ← RECTYPE(HOW);
IF RT = LOC(VARIABLE) THEN RT ← DTYPE(VARIABLE:DATATYPE[HOW])
ELSE IF RT = LOC(EXPRN) THEN RT ← EXPRN:DATATYPE[HOW];
IF RT = LOC(V3ECT) THEN RETURN(NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,
LIST2(NILROTN,HOW)))
ELSE RETURN(HOW);
END
ELSE RETURN(STAN_DEPROACH);
END;
! dexprset, domove;
PROCEDURE DEXPRSET(RPTR(DEXPR) DE; REXPR DX,TX; INTEGER DATATYPE; RTHREAD WLD);
BEGIN
! DX is destination expression from MOVE statement.
TX is correction from affixment structure.
Actual destination should be DX*inv(TX).
Computes planning value in current world & puts away in
VAL[DE].;
IF TX≠NULL_RECORD THEN
BEGIN
IF DATATYPE=FRAME_DTYPE THEN
DX ← NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(DX,INVSIMP(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,
CONS(TX,NULL_RECORD))) ))
ELSE
BUG("DEXPRTYPE CANNOT HANDLE DATATYPE ");
END;
IF RECTYPE(DX)≠LOC(VARIABLE) THEN
IF RECTYPE(DX)≠LOC(EXPRN) THEN
BEGIN
DEXPR:EXPN[DE]←DX;
DEXPR:VAL[DE]←DX;
END
ELSE
BEGIN
IF DEXPR:TMPVAR[DE]≠NULL_RECORD THEN
BEGIN
IF VARIABLE:DATATYPE[DEXPR:TMPVAR[DE]]≠DATATYPE THEN
BUG("WARNING: INCOMPATIBLE TYPES IN USE OF TEMP");
END
ELSE
DEXPR:TMPVAR[DE]←NEW_VAR(".T"&CVS(TEMP←TEMP+1),DATATYPE,CURBLK);
DEXPR:VAR[DE]←DEXPR:TMPVAR[DE];
DEXPR:EXPN[DE]←DX;
DEXPR:VAL[DE]←EVALEXPR(DX,WLD);
VCHANGE(DEXPR:VAR[DE],DEXPR:VAL[DE],WLD);
END
ELSE
BEGIN
DEXPR:VAR[DE]←DEXPR:EXPN[DE]←DX;
DEXPR:VAL[DE]←GETVALUE(DX,WLD);
END;
END;
RANY CURRENT_CF;
RECURSIVE PROCEDURE DOMOVE(RPTR(STMNT) S; RTHREAD WLD);
BEGIN
RPTR(EXPRN) E;
RCELL SEEN,C;
RANY ONM,X,OLD_CF;
RPTR(MOVE$) MS;
REXPR DEP;
RPTR(APPROACH) ARR;
RPTR(FORCE) F;
RPTR(F_FRAME) F_F;
RPTR(SETBASE) ZWRIST;
BOOLEAN ARRIVE,DEPART;
INTEGER DT,RT,USE_FORCE,CM_FORCE,USE_COMPLY,I;
MS ← STMNT:SEMANTICS[S];
SEEN ← RNULL;
IF MOVE$:WHAT[MS]=YHAND ∨ MOVE$:WHAT[MS]=BHAND THEN
BEGIN
E ← NULL_RECORD;
DT←SVAL_DTYPE;
MOVE$:CF[MS] ← MOVE$:WHAT[MS];
MOVE$:SFAC[MS] ← 1.0; ! Assume a speed factor of 1 unless explicitly given;
END
ELSE
BEGIN
DT←FRAME_DTYPE;
IF ¬CONTROLLABLE(MOVE$:WHAT[MS],MOVE$:CF[MS],E,SEEN) THEN
BEGIN
PRINT(CRLF & "WARNING: can't move: ", VARIABLE:NAME[MOVE$:WHAT[MS]]);
BUG("MOVE must have a controllable frame - assuming barm");
MOVE$:CF[MS] ← BARM;
END;
MOVE$:SFAC[MS] ← SVAL:VAL[GETVALUE(SPEED_FACTR,WLD,TRUE)]; ! Get global speed factor;
END;
OLD_CF ← CURRENT_CF;
CURRENT_CF ← MOVE$:CF[MS];
MOVE$:CFVAL[MS] ← GETVALUE(MOVE$:CF[MS],WLD);
DEXPRSET(MOVE$:DEXP[MS],MOVE$:DEST[MS],E,DT,WLD);
C←MOVE$:CLAUSES[MS];
WHILE C≠NULL_RECORD DO
BEGIN
X←LLOP(C);
IF (RT←RECTYPE(X))=LOCATION(CMON) THEN
BEGIN
RPTR(STMNT) SS;
RTHREAD NWLD;
IF MOVE$:CF[MS] = YARM THEN
CMON:FLAGS[X] ← CMON:FLAGS[X] + W_ARM; ! Remember which arm;
SS←STMCHK(CMON:CONCLUSION[X]);
NWLD ← NEW_THREAD;
STINTERP(SS,NWLD);
POP_THREAD(NWLD); ! Undo effects of cmon;
IF CMON:CONDITION[X] = ARRIVAL THEN ! Replace ARRIVAL by an event;
CMON:CONDITION[X] ←
NEW_VAR(".AE"&CVS(TEMP←TEMP+1),EVENT_DTYPE,CURBLK)
ELSE IF RECTYPE(CMON:CONDITION[X]) = LOC(FORCE) THEN
BEGIN ! See if we should stop arm when cmon is triggered;
RANY XX;
RCELL CC;
CM_FORCE ← CM_FORCE + 1;
XX ← STMNT:SEMANTICS[SS];
IF RECTYPE(XX) = LOC(STOP) ∧ STOP:CF[XX] = MOVE$:CF[MS] THEN
BEGIN
CMON:FLAGS[X] ← CMON:FLAGS[X] + FSTOP;
CMON:CONCLUSION[X] ← RNULL
END
ELSE IF RECTYPE(XX) = LOC(BLOCK) THEN
BEGIN ! Check if first statement is a STOP;
CC ← BLOCK:CODE[XX];
WHILE RECTYPE(CELL:CAR[CC]) ≠ LOC(STMNT) DO CC ← CELL:CDR[CC];
IF CC ≠ RNULL THEN XX ← STMNT:SEMANTICS[CELL:CAR[CC]];
IF RECTYPE(XX) = LOC(STOP) ∧ STOP:CF[XX] = MOVE$:CF[MS] THEN
BEGIN
CMON:FLAGS[X] ← CMON:FLAGS[X] + FSTOP;
IF CELL:CDR[CC] ≠ RNULL THEN
BEGIN ! Splice out this cell from list;
CELL:CAR[CC] ← CELL:CAR[CELL:CDR[CC]];
CELL:CDR[CC] ← CELL:CDR[CELL:CDR[CC]];
END
ELSE CELL:CAR[CC] ← RNULL;
END
END
END
END
ELSE IF RT=LOCATION(ERROR) THEN
BEGIN
RTHREAD NWLD;
ERROR:BITS[X] ← EVALEXPR(ERROR:BITS[X],WLD);
NWLD ← NEW_THREAD;
STINTERP(STMCHK(ERROR:BODY[X]),NWLD);
POP_THREAD(NWLD); ! Undo effects of error handler;
END
ELSE IF RT=LOCATION(FORCE) THEN
BEGIN
USE_FORCE ← USE_FORCE + 1;
END
ELSE IF RT=LOCATION(STIFF) THEN
BEGIN
USE_COMPLY ← 1;
IF STIFF:F_F[X] = RNULL THEN ! Fill in default force_frame;
BEGIN
STIFF:F_F[X] ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[STIFF:F_F[X]] ← STATION; ! Use standard orientation;
F_FRAME:C_SYS[STIFF:F_F[X]] ← FTABLE; ! Use table coordinates;
END
END
ELSE IF RT=LOCATION(F_FRAME) THEN
BEGIN
F_F ← X; ! Remember force frame;
END
ELSE IF RT=LOCATION(SETBASE) THEN
BEGIN
ZWRIST ← X; ! Remember whether we need to zero wrist or not;
END
ELSE IF RT=LOCATION(S_FAC) THEN
BEGIN
S_FAC:VAL[X] ← EVALEXPR(S_FAC:VAL[X],WLD);
MOVE$:SFAC[MS] ← SVAL:VAL[S_FAC:VAL[X]]; ! Bind local speed factor;
END
ELSE IF RT=LOCATION(WOBBLE) THEN
BEGIN
WOBBLE:VAL[X] ← EVALEXPR(WOBBLE:VAL[X],WLD);
END
ELSE IF RT=LOCATION(VIA) THEN
BEGIN
DEXPRSET(VIA:ACTPLACE[X],VIA:PLACE[X],E,DT,WLD);
IF VIA:CODE[X] ≠ RNULL ∧ RECTYPE(VIA:CODE[X]) = LOC(CMON) THEN
BEGIN
RPTR(STMNT) SS;
RTHREAD NWLD;
SS←STMCHK(CMON:CONCLUSION[VIA:CODE[X]]);
NWLD ← NEW_THREAD;
STINTERP(SS,NWLD); ! Simulate VIA code;
POP_THREAD(NWLD); ! But undo it's effects;
END
END
ELSE IF RT=LOCATION(APPROACH) THEN
BEGIN
ARRIVE ← TRUE;
DEP ← APPROACH:THRU[X];
IF DEP ≠ NILDEPROACH THEN
BEGIN
ARR ← X;
IF (RT←RECTYPE(DEP))=LOC(VARIABLE) THEN
RT ← DTYPE(VARIABLE:DATATYPE[DEP])
ELSE IF RT=LOC(EXPRN) THEN RT←DTYPE(EXPRN:DATATYPE[DEP]);
IF RT = LOC(SVAL) THEN
DEP ← NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,
NEW_EXPRN(V3ECT_DTYPE,SVMUL_OP,LIST2(DEP,ZHAT))))
ELSE IF RT = LOC(V3ECT) THEN
DEP ← NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,DEP));
DEXPRSET(APPROACH:ACTPLACE[X],NEW_EXPRN(TRANS_DTYPE,
TTMUL_OP,LIST2(MOVE$:DEST[MS],DEP)),E,DT,WLD);
IF APPROACH:CODE[X] ≠ RNULL ∧
RECTYPE(APPROACH:CODE[X]) = LOC(CMON) THEN
BEGIN
RPTR(STMNT) SS;
RTHREAD NWLD;
SS←STMCHK(CMON:CONCLUSION[APPROACH:CODE[X]]);
NWLD ← NEW_THREAD;
STINTERP(SS,NWLD); ! Simulate APPROACH code;
POP_THREAD(NWLD); ! But undo it's effects;
END
END;
END
ELSE IF RT=LOCATION(DEPARTURE) THEN
BEGIN
DEPART ← TRUE;
DEP ← DEPARTURE:THRU[X];
IF DEP ≠ NILDEPROACH THEN
BEGIN
IF (RT←RECTYPE(DEP))=LOC(VARIABLE) THEN
RT ← DTYPE(VARIABLE:DATATYPE[DEP])
ELSE IF RT=LOC(EXPRN) THEN RT←DTYPE(EXPRN:DATATYPE[DEP]);
IF RT = LOC(SVAL) THEN
DEP ← NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,
NEW_EXPRN(V3ECT_DTYPE,SVMUL_OP,LIST2(DEP,ZHAT))))
ELSE IF RT = LOC(V3ECT) THEN
DEP ← NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,DEP));
DEP ← IF E = NULL_RECORD THEN
NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,LIST2(MOVE$:CF[MS],DEP))
ELSE NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,LIST2(
NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(MOVE$:CF[MS],E)),DEP));
DEXPRSET(DEPARTURE:ACTPLACE[X],EVALEXPR(DEP,WLD),E,DT,WLD);
IF DEPARTURE:CODE[X] ≠ RNULL ∧
RECTYPE(DEPARTURE:CODE[X]) = LOC(CMON) THEN
BEGIN
RPTR(STMNT) SS;
RTHREAD NWLD;
SS←STMCHK(CMON:CONCLUSION[DEPARTURE:CODE[X]]);
NWLD ← NEW_THREAD;
STINTERP(SS,NWLD); ! Simulate DEPARTURE code;
POP_THREAD(NWLD); ! But undo it's effects;
END
END
END
END;
IF ¬ARRIVE ∧ DT=FRAME_DTYPE ∧ RECTYPE(MOVE$:DEST[MS])=LOC(VARIABLE) THEN
BEGIN ! add approach;
DEP ← DEPR(MOVE$:DEST[MS]);
IF DEP ≠ NILDEPROACH THEN
BEGIN
ARR ← NEW_RECORD(APPROACH);
CONSON(ARR,MOVE$:CLAUSES[MS]);
APPROACH:ACTPLACE[ARR] ← NEW_RECORD(DEXPR);
IF DEP = STAN_DEPROACH
THEN DEXPRSET(APPROACH:ACTPLACE[ARR],NEW_EXPRN(TRANS_DTYPE,
TVADD_OP,LIST2(MOVE$:DEST[MS],DEP)),E,DT,WLD)
ELSE DEXPRSET(APPROACH:ACTPLACE[ARR],NEW_EXPRN(TRANS_DTYPE,
TTMUL_OP,LIST2(MOVE$:DEST[MS],DEP)),E,DT,WLD)
END
END;
IF ¬DEPART ∧ ( (MOVE$:CF[MS]=BARM ∧ GETVALUE(BDEPROACH,WLD) ≠ NILDEPROACH) ∨
(MOVE$:CF[MS]=YARM ∧ GETVALUE(YDEPROACH,WLD) ≠ NILDEPROACH) ) THEN
BEGIN ! add departure;
RPTR(DEPARTURE) DPR;
DPR ← NEW_RECORD(DEPARTURE);
CONSON(DPR,MOVE$:CLAUSES[MS]);
DEPARTURE:ACTPLACE[DPR] ← NEW_RECORD(DEXPR);
DEP ← IF MOVE$:CF[MS]=BARM THEN BDEPROACH ELSE YDEPROACH;
DEXPRSET(DEPARTURE:ACTPLACE[DPR],DEP,RNULL,DT,WLD);
END;
IF DT=FRAME_DTYPE THEN
IF ARR = RNULL THEN
IF MOVE$:CF[MS]=BARM THEN VCHANGE(BDEPROACH,NILDEPROACH,WLD)
ELSE VCHANGE(BDEPROACH,NILDEPROACH,WLD)
ELSE IF MOVE$:CF[MS]=BARM THEN
VCHANGE(BDEPROACH,DEXPR:VAL[APPROACH:ACTPLACE[ARR]],WLD)
ELSE VCHANGE(YDEPROACH,DEXPR:VAL[APPROACH:ACTPLACE[ARR]],WLD);
IF ¬ USE_FORCE ∧ CM_FORCE = 1 THEN
BEGIN "only sense"
C ← MOVE$:CLAUSES[MS];
DO X ← LLOP(C) UNTIL RECTYPE(X)=LOC(CMON) ∧
RECTYPE(CMON:CONDITION[X])=LOC(FORCE);
F ← CMON:CONDITION[X];
IF FORCE:F_F[F] = RNULL ∧ F_F = RNULL ∧ (FORCE:DIRECT[F] = XHAT ∨
FORCE:DIRECT[F] = YHAT ∨ FORCE:DIRECT[F] =ZHAT ∨
(RECTYPE(X←FORCE:DIRECT[F]) = LOC(V3ECT) ∧
( V3CMP(X,NEGXHAT)=0 ∨ V3CMP(X,NEGYHAT)=0 ∨
V3CMP(X,NEGZHAT)=0 ) ) ) THEN
BEGIN ! Need to specify a force frame;
FORCE:F_F[F] ← F_F ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[F_F] ← STATION; ! Use standard orientation;
F_FRAME:C_SYS[F_F] ← FTABLE; ! Use table coordinates;
END;
IF (F_F ← FORCE:F_F[F]) ≠ RNULL THEN F_FRAME:C_SYS[F_F] ←
F_FRAME:C_SYS[F_F] lor
MEMLOC(IF MOVE$:CF[MS]=YARM THEN YELARM ELSE BLUARM,INTEGER);
END "only sense"
ELSE IF USE_FORCE ∨ CM_FORCE THEN
BEGIN "multiple sense/apply"
I ← USE_FORCE + CM_FORCE;
C ← MOVE$:CLAUSES[MS];
WHILE I DO
BEGIN "find the force clauses"
X ← LLOP(C);
IF (RT←RECTYPE(X))=LOC(CMON) ∧ RECTYPE(CMON:CONDITION[X])=LOC(FORCE)
THEN F ← CMON:CONDITION[X]
ELSE IF RT=LOC(FORCE) THEN F ← X ELSE CONTINUE;
I ← I - 1;
IF RECTYPE(FORCE:DIRECT[F]) = LOC(V3ECT) ∧
( V3CMP(FORCE:DIRECT[F],NEGXHAT)=0 ∨
V3CMP(FORCE:DIRECT[F],NEGYHAT)=0 ∨
V3CMP(FORCE:DIRECT[F],NEGZHAT)=0 ) THEN
BEGIN ! Reverse direction of axis & flip rel;
IF V3CMP(FORCE:DIRECT[F],NEGXHAT)=0 THEN FORCE:DIRECT[F]←XHAT ELSE
IF V3CMP(FORCE:DIRECT[F],NEGYHAT)=0 THEN FORCE:DIRECT[F]←YHAT
ELSE FORCE:DIRECT[F]←ZHAT;
FORCE:REL[F] ← FORCE:REL[F] XOR (SIGLT LOR SIGGE);
END;
IF FORCE:DIRECT[F]≠XHAT ∧FORCE:DIRECT[F]≠YHAT ∧FORCE:DIRECT[F]≠ZHAT THEN
IF USE_FORCE + CM_FORCE = 1 THEN
BEGIN "single apply"
IF F_F ≠ RNULL THEN
BEGIN ! Multiply defined force frames;
ALPRIN(MS);
BUG("MOVE statement has multiply defined force frames");
END;
IF FORCE:F_F[F] = RNULL THEN ! Make up a force frame;
BEGIN
FORCE:F_F[F] ← NEW_RECORD(F_FRAME);
F_FRAME:C_SYS[FORCE:F_F[F]] ← FTABLE
END
ELSE IF TRANSCMP(FRAME:VAL[F_FRAME:FRAME[FORCE:F_F[F]]],NILTRANS) THEN
FORCE:DIRECT[F] ← NEW_EXPRN(V3ECT_DTYPE,RVMUL_OP,
LIST2(NEW_EXPRN(ROTN_DTYPE,ORIENT_OP,
CONS(F_FRAME:FRAME[FORCE:F_F[F]],RNULL)),
FORCE:DIRECT[F]));
F_FRAME:C_SYS[FORCE:F_F[F]] ← F_FRAME:C_SYS[FORCE:F_F[F]] +
(IF MOVE$:CF[MS]=YARM THEN YELARM ELSE BLUARM);
DONE;
END "single apply"
ELSE BEGIN "axis error"
ALPRIN(MS);
PRINT(crlf & "Force direction must be along an axis" &
" - Assuming ZHAT");
FORCE:DIRECT[F] ← ZHAT;
END "axis error";
IF F_F = RNULL THEN F_F ← FORCE:F_F[F] ! Make the first force frame;
! we see the default, unless the MOVE specified one;
ELSE IF FORCE:F_F[F] ≠ RNULL ∧
(F_FRAME:FRAME[F_F]≠F_FRAME:FRAME[FORCE:F_F[F]] ∨
F_FRAME:C_SYS[F_F]≠F_FRAME:C_SYS[FORCE:F_F[F]]) THEN
BEGIN ! Multiply defined force frames;
ALPRIN(MS);
BUG("MOVE statement has multiply defined force frames");
END;
IF RT=LOC(CMON) THEN FORCE:F_F[F] ← RNULL; ! null out the field so;
! cmon's will be coded right - (a kluge?);
END "find the force clauses";
IF F_F = RNULL ∧ USE_FORCE+CM_FORCE > 1 THEN
BEGIN ! no force frame specified;
ALPRIN(MS);
PRINT(crlf &"No force frame specified in MOVE statement" &
" - Assuming station");
F_F ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[F_F] ← STATION; ! Use standard orientation;
F_FRAME:C_SYS[F_F] ← FTABLE; ! Use table coordinates;
END;
IF F_F ≠ RNULL THEN
BEGIN
F_FRAME:C_SYS[F_F] ← F_FRAME:C_SYS[F_F] lor
MEMLOC(IF MOVE$:CF[MS]=YARM THEN YELARM ELSE BLUARM,INTEGER);
CONSON(F_F,MOVE$:CLAUSES[MS]); ! May already be somewhere in clause list;
END; ! but...;
END "multiple sense/apply";
IF ZWRIST = RNULL ∧ CM_FORCE + USE_FORCE + USE_COMPLY ≥ 1 THEN
BEGIN ! Want to zero wrist;
ZWRIST ← NEW_RECORD(SETBASE);
SETBASE:VAL[ZWRIST] ← TRUE;
CONSON(ZWRIST,MOVE$:CLAUSES[MS]);
END;
IF USE_FORCE ∧ ¬USE_COMPLY THEN
BEGIN ! Need to add a stiffness specification;
X ← NEW_RECORD(STIFF);
STIFF:K[X] ← NEW_V3ECT(90.0,90.0,90.0);
STIFF:G[X] ← NEW_V3ECT(20000.0,20000.0,500.0);
STIFF:F_F[X] ← NEW_RECORD(F_FRAME); ! Fill in default force_frame;
F_FRAME:FRAME[STIFF:F_F[X]] ← STATION; ! Use standard orientation;
F_FRAME:C_SYS[STIFF:F_F[X]] ← FTABLE; ! Use table coordinates;
CONSON(X,MOVE$:CLAUSES[MS]);
END;
VCHANGE(MOVE$:CF[MS],DEXPR:VAL[MOVE$:DEXP[MS]],WLD);
CURRENT_CF ← OLD_CF;
END;
! dooperate, docenter, dostop;
RECURSIVE PROCEDURE DOOPERATE(RPTR(STMNT) S; RTHREAD WLD);
BEGIN ! only for vise & driver;
RPTR(EXPRN) E;
RCELL C;
BOOLEAN CCW;
RANY OLD_CF,VAL,VAL2;
RPTR(OPERATE) MS;
MS ← STMNT:SEMANTICS[S];
IF OPERATE:WHAT[MS] ≠ VISE ∧ OPERATE:WHAT[MS] ≠ DRIVER THEN
BEGIN ! not a valid device;
PRINT(CRLF & "WARNING: can't operate: ", VARIABLE:NAME[OPERATE:WHAT[MS]]);
BUG("ignoring statement");
RETURN
END;
OPERATE:CF[MS] ← OPERATE:WHAT[MS];
OLD_CF ← CURRENT_CF;
CURRENT_CF ← OPERATE:CF[MS];
C←OPERATE:CLAUSES[MS];
WHILE C≠NULL_RECORD DO
BEGIN ! simulate any cmons;
RANY X;INTEGER RT;
X←LLOP(C);
IF (RT←RECTYPE(X))=LOCATION(CMON) THEN
BEGIN
RTHREAD NWLD;
NWLD ← NEW_THREAD;
STINTERP(STMCHK(CMON:CONCLUSION[X]),NWLD);
POP_THREAD(NWLD); ! Undo effects of cmon;
END
ELSE IF RT=LOCATION(ERROR) THEN
BEGIN
RTHREAD NWLD;
ERROR:BITS[X] ← EVALEXPR(ERROR:BITS[X],WLD);
NWLD ← NEW_THREAD;
STINTERP(STMCHK(ERROR:BODY[X]),NWLD);
POP_THREAD(NWLD); ! Undo effects of error handler;
END
ELSE IF RT=LOCATION(CW) THEN CCW ← CW:FLAG[X]
END;
IF OPERATE:CF[MS] = VISE THEN
BEGIN
VAL2 ← GETVALUE(FIXED_JAW,WLD,TRUE);
IF VAL2 = NILDEPROACH THEN ! Try to update the fixed_jaw position;
BEGIN
VAL2 ← GETVALUE(MOVING_JAW,WLD,TRUE);
VAL ← GETVALUE(VISE_OPENING,WLD,TRUE);
IF VAL2 ≠ NILDEPROACH THEN ! Can update the fixed_jaw position;
VCHANGE(FIXED_JAW,TTMUL(VAL2,TINVRT(VAL)),WLD);
END;
IF RECTYPE(OPERATE:DEST[MS]) = LOC(CHAR_REC) THEN
IF CHAR_REC:CHAR[OPERATE:DEST[MS]] = "-" THEN VAL ← FALSEV
ELSE VAL ← NEW_SVAL(MAX_VISE_OPENING)
ELSE VAL ← EVALEXPR(OPERATE:DEST[MS],WLD);
VCHANGE(VISE,VAL,WLD);
VAL ← NEW_TRANS(NILROTN,SVMUL(SVAL:VAL[VAL],YHAT));
VCHANGE(VISE_OPENING,VAL,WLD);
VAL2 ← GETVALUE(FIXED_JAW,WLD,TRUE);
IF VAL2 ≠ NILDEPROACH THEN ! Update the moving_jaw position;
VCHANGE(FIXED_JAW,TTMUL(VAL2,VAL),WLD);
END
ELSE IF OPERATE:CF[MS] = DRIVER ∧ CCW THEN ! Need to negate ang_vel/torque;
BEGIN
C←OPERATE:CLAUSES[MS];
WHILE C≠NULL_RECORD DO
BEGIN ! find clauses to negate;
RANY X;INTEGER RT;
X←LLOP(C);
IF (RT←RECTYPE(X))=LOCATION(FORCE) THEN
BEGIN ! negate torque;
FORCE:VAL[X] ← IF RECTYPE(FORCE:VAL[X])=LOC(SVAL) THEN
NEW_SVAL(-SVAL:VAL[FORCE:VAL[X]])
ELSE NEW_EXPRN(SVAL_DTYPE,SNEG_OP,CONS(FORCE:VAL[X],RNULL))
END
ELSE IF RT=LOCATION(VELOCITY) THEN
BEGIN ! negate velocity;
VELOCITY:VELOC[X] ← IF RECTYPE(VELOCITY:VELOC[X])=LOC(SVAL) THEN
NEW_SVAL(-SVAL:VAL[VELOCITY:VELOC[X]])
ELSE NEW_EXPRN(SVAL_DTYPE,SNEG_OP,CONS(VELOCITY:VELOC[X],RNULL))
END
END
END;
CURRENT_CF ← OLD_CF;
END;
RECURSIVE PROCEDURE DOCENTER(RPTR(STMNT) S; RTHREAD WLD);
BEGIN
RCELL C;
RPTR(CENTER) MS;
MS ← STMNT:SEMANTICS[S];
C ← CENTER:CLAUSES[MS];
WHILE C ≠ NULL_RECORD DO
BEGIN ! simulate error handler;
RANY X;
X←LLOP(C);
IF RECTYPE(X)=LOCATION(ERROR) THEN
BEGIN
RTHREAD NWLD;
ERROR:BITS[X] ← EVALEXPR(ERROR:BITS[X],WLD);
NWLD ← NEW_THREAD;
STINTERP(STMCHK(ERROR:BODY[X]),NWLD);
POP_THREAD(NWLD); ! Undo effects of error handler;
END
END
END;
RECURSIVE PROCEDURE DOSTOP(RPTR(STMNT) S);
BEGIN ! Added by ARG;
RPTR(EXPRN) E;
RCELL SEEN;
RPTR(STOP) MS;
MS ← STMNT:SEMANTICS[S];
SEEN ← RNULL;
IF STOP:CF[MS] = RNULL ∧ CURRENT_CF ≠ RNULL THEN STOP:CF[MS] ← CURRENT_CF
ELSE IF STOP:CF[MS]=RNULL ∨ ¬( DEVICE(STOP:CF[MS])
∨ CONTROLLABLE(STOP:CF[MS],STOP:CF[MS],E,SEEN) ) THEN
BEGIN
PRINT(crlf &"STOP MUST HAVE A CONTROLLABLE FRAME - ASSUMING BARM" & crlf);
STOP:CF[MS]←BARM;
END;
END;
! do_affix, do_unfix;
INTERNAL PROCEDURE DO_UNFIX(RTHREAD WLD;RANY F1,F2);
BEGIN
RCELL C1,C2;
PROCEDURE REMCALC (RVAR V1,V2);
BEGIN
RPTR(CALC) C,C1,C2;
C ← VARIABLE:CALCS[V1]; ! Remove calc for V1;
C2 ← RNULL;
WHILE C ≠ RNULL ∧ CALC:OTHER[C] ≠ V2 DO C ← CALC:NXTCALC[(C2←C)];
IF C ≠ RNULL THEN ! Found it, remove it from chain;
IF C2 = RNULL THEN VARIABLE:CALCS[V1] ← CALC:NXTCALC[C]
ELSE CALC:NXTCALC[C2] ← CALC:NXTCALC[C]
ELSE RETURN; ! We don't have a calc;
IF CALC:THREAD[C] ≠ WLD THEN ! Put on list for later restoration;
BEGIN
RPTR(CALC) C1,C2;
C1 ← THREAD:REMCALCS[WLD];
IF C1 = RNULL ∨ CALC:US[C] < CALC:US[C1]
∨ (CALC:US[C]=CALC:US[C1] ∧ CALC:OTHER[C]≤CALC:OTHER[C1]) THEN
BEGIN
CALC:REMCALC[C] ← C1;
THREAD:REMCALCS[WLD] ← C
END
ELSE
BEGIN ! Splice us onto the list;
WHILE C1≠RNULL ∧ (CALC:US[C1] < CALC:US[C]
∨ (CALC:US[C1]=CALC:US[C] ∧ CALC:OTHER[C1]≤CALC:OTHER[C]))
DO C1 ← CALC:REMCALC[(C2←C1)];
CALC:REMCALC[C] ← C1;
CALC:REMCALC[C2] ← C
END
END
END;
IF RECTYPE(F1) = LOC(EXPRN) THEN F1 ← ARRAYREF(F1,WLD);
IF RECTYPE(F2) = LOC(EXPRN) THEN F2 ← ARRAYREF(F2,WLD);
GETVALUE(F1,WLD,TRUE); ! Validate the two frames if possible;
GETVALUE(F2,WLD,TRUE);
REMCALC(F1,F2); ! Remove calc for F1;
REMCALC(F2,F1); ! Remove calc for F2;
END;
PROCEDURE DO_AFFIX (RTHREAD WLD; RANY F1,F2,BV; REXPR AE; BOOLEAN RGF);
BEGIN
RPTR(CALC) C;
PROCEDURE ADDCALC(RPTR(CALC) C);
BEGIN
RPTR(CALC) C1,C2;
CALC:THREAD[C] ← WLD;
CALC:NXTCALC[C] ← VARIABLE:CALCS[CALC:US[C]];
VARIABLE:CALCS[CALC:US[C]] ← C; ! Add us to variable's calc list;
C1 ← THREAD:CALCS[WLD];
IF C1 = RNULL ∨ CALC:US[C] < CALC:US[C1]
∨ (CALC:US[C]=CALC:US[C1] ∧ CALC:OTHER[C]≤CALC:OTHER[C1]) THEN
BEGIN
CALC:NEXT[C] ← C1;
THREAD:CALCS[WLD] ← C
END
ELSE
BEGIN ! Splice us onto the list;
WHILE C1≠RNULL ∧ (CALC:US[C1] < CALC:US[C]
∨ (CALC:US[C1]=CALC:US[C] ∧ CALC:OTHER[C1]≤CALC:OTHER[C]))
DO C1 ← CALC:NEXT[(C2←C1)];
CALC:NEXT[C] ← C1;
CALC:NEXT[C2] ← C
END
END;
IF RECTYPE(F1) = LOC(EXPRN) THEN F1 ← ARRAYREF(F1,WLD);
IF RECTYPE(F2) = LOC(EXPRN) THEN F2 ← ARRAYREF(F2,WLD);
IF RECTYPE(BV) = LOC(EXPRN) THEN BV ← ARRAYREF(BV,WLD);
DO_UNFIX(WLD,F1,F2); ! Make sure they're not currently affixed;
IF AE=NULL_RECORD THEN ! FTOF(F2,F1);
AE←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,CONS(F2,NULL_RECORD)),F1));
VCHANGE(BV,EVALEXPR(AE,WLD),WLD);
C ← NEW_RECORD(CALC);
CALC:US[C] ← F1; ! f1 ← ttmul(f2,bv);
CALC:OTHER[C] ← F2;
CALC:BVAR[C] ← BV;
IF RGF THEN CALC:TYPE[C] ← 1; ! Rigid affixment;
ADDCALC(C);
C ← NEW_RECORD(CALC);
CALC:US[C] ← F2; ! f2 ← ttmul(f1,tinvrt(bv));
CALC:OTHER[C] ← F1;
CALC:BVAR[C] ← BV;
CALC:TYPE[C] ← IF RGF THEN 1+2 ! Rigid affixment + Frame 2;
ELSE 2; ! Non-rigid + frame 2 (changer not calc);
ADDCALC(C);
END;
! blockdo & sttblk;
RECPROC BLOCKDO(RPTR(STMNT) S; RTHREAD WLD);
BEGIN
RTHREAD NWLD;
RCELL C;
RPTR(BLOCK) OCB;
OCB←CURBLK;
CURBLK←STMNT:SEMANTICS[S];
C←BLOCK:ARAYS[CURBLK];
WHILE C≠RNULL DO
BEGIN "alloc arrays"
INTEGER I,J,SIZE;
RPTR(ARRAYDEF) A;
RVAR V;
A ← LLOP(C);
FOR I ← 1 TIL ARRAYDEF:NUMDIMS[A] DO
FOR J ← 0 TIL 1 DO ! bind array bounds;
ARRAYDEF:BDVALS[A][I,J] ←
SVAL:VAL[EVALEXPR(ARRAYDEF:BOUNDS[A][I,J],WLD)];
SIZE ← 1;
FOR I ← ARRAYDEF:NUMDIMS[A] STEP -1 UNTIL 1 DO
BEGIN ! compute array size;
ARRAYDEF:BDVALS[A][I,2] ← SIZE;
SIZE ← SIZE *
(ARRAYDEF:BDVALS[A][I,1]-ARRAYDEF:BDVALS[A][I,0]+1)
END;
NewArray(RVAR,ARRAYDEF:VARS[A],[1:SIZE]);
FOR I ← 1 TIL SIZE DO
BEGIN ! initialize all the variables;
ARRAYDEF:VARS[A][I] ← V ← NEW_RECORD(VARIABLE);
VARIABLE:NAME[V]←ARRAYDEF:NAME[A];
VARIABLE:DATATYPE[V]←ARRAYDEF:DATATYPE[A];
VARIABLE:BLK[V]←ARRAYDEF:BLK[A]
END
END "alloc arrays";
C←BLOCK:PROCS[CURBLK];
WHILE C≠RNULL DO
BEGIN ! simulate procedures;
NWLD ← NEW_THREAD;
STINTERP(PROCDEF:BODY[LLOP(C)],NWLD);
POP_THREAD(NWLD); ! Undo any effects procedure might have had;
END;
NWLD ← NEW_THREAD;
C←BLOCK:CODE[CURBLK];
WHILE C≠NULL_RECORD DO
BEGIN
INTEGER ST;
ST←RECTYPE(CELL:CAR[C]);
IF ST = LOC(EXPRN) ∧ EXPRN:OP[CELL:CAR[C]]=CALL_OP THEN
BEGIN
CELL:CAR[C] ← STMAKE(CELL:CAR[C]);
ST ← RECTYPE(CELL:CAR[C])
END;
IF ST=LOC(STMNT) THEN STINTERP(CELL:CAR[C],NWLD)
ELSE IF ST=LOC(PVL) THEN PVLDO(PVL:VL[CELL:CAR[C]],NWLD)
ELSE IF ST=LOC(VARIABLE) THEN BEGIN END
ELSE IF ST=LOC(NOTE) THEN
PRINT(STCONST:VAL[NOTE:HESAYS[CELL:CAR[C]]],CRLF)
ELSE IF ST=LOC(NOTE1) THEN
PRINT(STCONST:VAL[NOTE1:HESAYS[CELL:CAR[C]]],CRLF)
ELSE IF ST=LOC(NOTE2) THEN BEGIN END
ELSE IF CELL:CAR[C] ≠ RNULL THEN USERERR(1,1,"FUNNY BLOCK ELEMENT");
C←CELL:CDR[C];
END;
C←BLOCK:VARS[CURBLK];
WHILE C≠NULL_RECORD DO KILLVAR(NWLD,LLOP(C));
C←BLOCK:ARAYS[CURBLK];
WHILE C≠NULL_RECORD DO
BEGIN ! dealloc arrays;
RPTR(ARRAYDEF) H;
INTEGER I,N;
H ← LLOP(C);
N ← ARRINFO(ARRAYDEF:VARS[H],2); ! get array size;
FOR I ← 1 TIL N DO KILLVAR(NWLD,ARRAYDEF:VARS[H][I]);
ARYEL(MEMORY[LOCATION(ARRAYDEF:VARS[H])]);
END;
POP_THREAD(NWLD); ! Undo effects of this thread;
PUSH_THREAD(NWLD,WLD); ! & propagate them to parent thread;
CURBLK←OCB;
END;
INTERNAL RANY PROCEDURE STTBLK(RANY S); ! Used to be rptr(block) procedure;
BEGIN
RPTR(BLOCK) B;
IF RECTYPE(S)≠LOC(BLOCK) THEN
BEGIN
B←NEW_RECORD(BLOCK);
BLOCK:CODE[B]←CONS(S,NULL_RECORD);
RETURN(STMAKE(B));
END;
RETURN(S);
END;
! Cobdo;
RECPROC COBDO(RPTR(STMNT) S; RTHREAD WLD);
BEGIN
RTHREAD T,NWLD;
RCELL C;
RPTR(STMNT) SS;
NWLD ← NEW_THREAD;
C←COBLOCK:CODE[CHKREC(STMNT:SEMANTICS[S],LOC(COBLOCK))];
WHILE C≠NULL_RECORD DO
BEGIN
SS←STMCHK(CELL:CAR[C]);
T ← NEW_THREAD;
STINTERP(SS,T);
POP_THREAD(T);
NWLD ← MERGE_THREADS(T,NWLD);
C←CELL:CDR[C];
END;
PUSH_THREAD(NWLD,WLD); ! Propagate effects to parent thread;
END;
! statement interpreter: stinterp;
INTERNAL RECPROC STINTERP(RPTR(STMNT) S; RTHREAD WLD);
BEGIN
! Takes the statement S and interprets what it would do modifying
the world associated with the thread WLD;
INTEGER STYP;
RSSS SS;
RPTR(STMNT) S1,S2;
RTHREAD T1,T2;
IF S=NULL_RECORD THEN RETURN;
IF RECTYPE(S) ≠ LOC(STMNT) THEN
BEGIN
USERERR(1,1,"STINTERP: Not a statement");
RETURN
END;
SS←STMNT:SEMANTICS[S];
STYP←RECTYPE(SS);
IF SS=NULL_RECORD THEN RETURN;
IF STYP=LOC(BLOCK) THEN BLOCKDO(S,WLD)
ELSE IF STYP=LOC(ASSIGNMENT) THEN
VCHANGE(ASSIGNMENT:VAR[SS],EVALEXPR(ASSIGNMENT:VAL[SS],WLD),WLD)
ELSE IF STYP=LOC(PAS) THEN
VCHANGE(PAS:VAR[SS],EVALEXPR(PAS:VAL[SS],WLD),WLD)
ELSE IF STYP=LOC(DEPROACH) THEN
DCHANGE(DEPROACH:VAR[SS],DEPROACH:VAL[SS],WLD)
ELSE IF STYP=LOC(IFF) THEN
BEGIN
T1 ← NEW_THREAD;
T2 ← NEW_THREAD;
STINTERP(STMCHK(IFF:THN[SS]),T1);
POP_THREAD(T1); ! Undo effects of THEN clause;
STINTERP(STMCHK(IFF:ELS[SS]),T2);
POP_THREAD(T2); ! Undo effects of ELSE clause;
T1 ← AND_THREADS(T1,T2); ! See what's the same in both;
PUSH_THREAD(T1,WLD); ! & propagate it into WLD;
END
ELSE IF STYP=LOC(COBLOCK) THEN COBDO(S,WLD)
ELSE IF STYP=LOC(WHIL) THEN STINTERP(STMCHK(WHIL:BODY[SS]),WLD)
ELSE IF STYP=LOC(UNTL) THEN STINTERP(STMCHK(UNTL:BODY[SS]),WLD)
ELSE IF STYP=LOC(FORR) THEN
BEGIN
VCHANGE(FORR:CONVAR[SS],EVALEXPR(FORR:INITIAL[SS],WLD),WLD);
STINTERP(STMCHK(FORR:BODY[SS]),WLD);
VCHANGE(FORR:CONVAR[SS],EVALEXPR(FORR:FINAL[SS],WLD),WLD);
END
ELSE IF STYP=LOC(KASE) THEN
BEGIN
RCELL C;
T2 ← RNULL;
C ← KASE:STMNTS[SS];
WHILE C ≠ RNULL DO
BEGIN
T1 ← NEW_THREAD;
STINTERP(LLOP(C),T1);
POP_THREAD(T1); ! Undo the effects of this one;
IF T2 = RNULL THEN T2 ← T1 ! Then AND it to the total;
ELSE T2 ← AND_THREADS(T1,T2)
END;
PUSH_THREAD(T2,WLD); ! & finally propagate the grand result;
END
ELSE IF STYP=LOC(AFFIX) THEN
DO_AFFIX(WLD,AFFIX:FRAME1[SS],AFFIX:FRAME2[SS],AFFIX:BYVAR[SS],
AFFIX:ATEXP[SS],AFFIX:RIGID[SS])
ELSE IF STYP=LOC(UNFIX) THEN DO_UNFIX(WLD,UNFIX:FRAME1[SS],UNFIX:FRAME2[SS])
ELSE IF STYP = LOC(MOVE$) THEN DOMOVE(S,WLD)
ELSE IF STYP = LOC(OPERATE) THEN DOOPERATE(S,WLD)
ELSE IF STYP = LOC(CENTER) THEN DOCENTER(S,WLD)
ELSE IF STYP = LOC(STOP) THEN DOSTOP(S)
ELSE IF STYP = LOC(COMMNT) ∨ STYP = LOC(RETRY) ∨ STYP = LOC(CMABLE)
∨ STYP = LOC(SETBASE) ∨ STYP = LOC(WRIST) ! Temp hacks?;
∨ STYP = LOC(PRNT) ∨ STYP = LOC(PAUSE) ∨ STYP = LOC(ABORT)
∨ STYP = LOC(PROMPT) ∨ STYP = LOC(RETRN) ∨ STYP = LOC(EXPRN)
∨ STYP = LOC(EVDO) THEN BEGIN ! Do nothing; END
ELSE IF STYP = LOC(CMON) THEN
BEGIN "cmon"
T1 ← NEW_THREAD;
STINTERP(STMCHK(CMON:CONCLUSION[SS]),T1);
POP_THREAD(T1); ! Ignore any effects the CMON may have;
IF CURRENT_CF = YARM THEN
CMON:FLAGS[SS] ← CMON:FLAGS[SS] + W_ARM; ! Remember which arm;
IF RECTYPE(CMON:CONDITION[SS]) = LOC(FORCE) THEN
BEGIN ! See if we should stop arm when cmon is triggered;
RANY XX;
RCELL CC;
XX ← STMNT:SEMANTICS[CMON:CONCLUSION[SS]];
IF RECTYPE(XX) = LOC(STOP) ∧ STOP:CF[XX] = CURRENT_CF THEN
BEGIN
CMON:FLAGS[SS] ← CMON:FLAGS[SS] + FSTOP;
CMON:CONCLUSION[SS] ← RNULL
END
ELSE IF RECTYPE(XX) = LOC(BLOCK) THEN
BEGIN ! Check if first statement is a STOP;
CC ← BLOCK:CODE[XX];
WHILE RECTYPE(CELL:CAR[CC]) ≠ LOC(STMNT) DO CC ← CELL:CDR[CC];
IF CC ≠ RNULL THEN XX ← STMNT:SEMANTICS[CELL:CAR[CC]];
IF RECTYPE(XX) = LOC(STOP) ∧ STOP:CF[XX] = CURRENT_CF THEN
BEGIN
CMON:FLAGS[SS] ← CMON:FLAGS[SS] + FSTOP;
IF CELL:CDR[CC] ≠ RNULL THEN
BEGIN ! Splice out this cell from list;
CELL:CAR[CC] ← CELL:CAR[CELL:CDR[CC]];
CELL:CDR[CC] ← CELL:CDR[CELL:CDR[CC]];
END
ELSE CELL:CAR[CC] ← RNULL;
END
END
END
END "cmon"
ELSE IF STYP = LOC(S_FAC) THEN
VCHANGE(SPEED_FACTR,EVALEXPR(S_FAC:VAL[SS],WLD),WLD)
ELSE IF STYP = LOC(PROG) THEN
BEGIN
RVAR VAR;
T1 ← NEW_THREAD;
VCHANGE(BARM,BPARK,T1); ! Initialize arm positions;
VCHANGE(BHAND,NEW_SVAL(2),T1);
VCHANGE(YARM,YPARK,T1);
VCHANGE(YHAND,NEW_SVAL(2),T1);
VCHANGE(SPEED_FACTR,NEW_SVAL(2.0),T1); ! Set speed_factor to 2;
VCHANGE(BDEPROACH,NILDEPROACH,T1); ! more initialization;
VCHANGE(YDEPROACH,NILDEPROACH,T1);
VCHANGE(VISE,NEW_SVAL(2.5),T1); ! yet more initialization: devices;
DO_AFFIX(T1,MOVING_JAW,FIXED_JAW,VISE_OPENING,
NEW_TRANS(NILROTN,SVMUL(2.5,YHAT)),TRUE); ! pseudo affixment;
DO_AFFIX(T1,DR_TIP,DR_GRASP,DR_TRANS,
NEW_TRANS(NILROTN,SVMUL(1.875,ZHAT)),TRUE);
STINTERP(PROG:CODE[SS],T1);
IF GETVALUE(BARM,T1,TRUE) ≠ BPARK THEN
PRINT("WARNING: Blue arm not parked upon program completion."&crlf);
IF GETVALUE(YARM,T1,TRUE) ≠ YPARK THEN
PRINT("WARNING: Yellow arm not parked upon program completion."&crlf);
END
ELSE
BEGIN
PRINT(CRLF&"***");
ALPRIN(SS);
USERERR(1,1," STINTERP GIVEN A STATEMENT TYPE IT CANNOT HANDLE");
END;
END;
END $$PRGID;